(loading pgmimage.ps...)print

DATA_DIR(/qsort.ps)strcat run

/newPPMIMAGEdevice { % width height  .  IMAGE-device-dict
    PPMIMAGE dup /Create get exec
} def

% PPMIMAGE device handles 24bit rgb images.
%
% It uses the full range 0-255 of values and does not calculate
% the actual maximum value in the data before transmitting. MaxVal
% is always 255.
%
% In the list of procedures below, PPMIMAGE is the Class dictionary,
% IMAGE is an instance returned by Create.
%
% procedures:
%           width height PPMIMAGE  Create  ->  IMAGE
%                 r g b x y IMAGE  PutPix  ->  -
%                       x y IMAGE  GetPix  ->  r g b
%         r g b x1 y1 x2 y2 IMAGE  DrawLine  ->  -
%    r g b x y width height IMAGE  DrawRect  ->  -
%    r g b x y width height IMAGE  FillRect  ->  -
%             r g b polygon IMAGE  FillPoly  ->  -
%                           IMAGE  Emit  ->  -
%                           IMAGE  Destroy  ->  -
%                           dict1  .copydict  dict2
% eg:
% PS> /dev 40 20 newPPMIMAGEdevice def
% PS> 55 1 1 38 17 dev dup /DrawLine get exec
% PS> 77 9 14 3 3 dev dup /FillRect get exec
% PS> dev dup /Emit get exec
%

/PPMIMAGE <<
    /nativecolorspace /DeviceRGB
    /dimensions [0 0]

    /.copydict {
        dup length dict copy
        dup /width known {
            dup begin
                /dimensions [width height] def
            end
        } if
        %dup /defaultmatrix known {
        %    dup /defaultmatrix 2 copy get matrix copy put
        %} if
    } bind
    /Create { % width height IMAGE  .  IMAGE'
    begin {/height /width}{exch def}forall
    currentdict end
    dup /.copydict get exec
    begin
        /ImgData height array def
        0 1 height 1 sub {
            ImgData exch width array
            0 1 width 1 sub {
                2 copy 0 put pop
            } for
            put
        } for
    currentdict
    end } bind

    /Destroy { % IMAGE  .  -
        pop
    }  bind

    /.to-int { floor cvi } bind
    /PutPix { % r g b x y IMAGE  .  -
    begin
        {
            .to-int exch .to-int exch
            dup height ge { stop } if
            1 index width ge { stop } if
            ImgData exch get exch % r g b img(y) x
            5 2 roll % img(y) x r g b
            255 mul cvi exch % img(y) x r int(b) g
            255 mul cvi 8 bitshift or exch % img(y) x int(b)|int(g) r
            255 mul cvi 16 bitshift or % img(y) x b|g|r
            put
        } stopped {
            pop pop pop pop pop
        } if
    end } bind

    /GetPix { % x y IMAGE  .  r g b
    begin
        .to-int exch .to-int exch
        ImgData exch get exch get
        dup -16 bitshift exch
        dup -8 bitshift 16#ff and exch
        16#ff and
    end } bind


    /.sign { dup 0 le { 0 lt { -1 }{ 0 } ifelse }{ pop 1 } ifelse } bind

    /DrawLine { % r g b x1 y1 x2 y2 IMAGE  .  -
    begin {y2 x2 y1 x1 b g r}{exch def}forall
        x1 0 lt{ x1 y1 x2 y2 0 0 0 height .intersect
			{ {y1 x1}{exch def}forall } if } if
        x2 0 lt{ x1 y1 x2 y2 0 0 0 height .intersect
			{ {y2 x2}{exch def}forall } if } if
        y1 0 lt{ x1 y1 x2 y2 0 0 width 0 .intersect
			{ {y1 x1}{exch def}forall } if } if
        y2 0 lt{ x1 y1 x2 y2 0 0 width 0 .intersect
			{ {y2 x2}{exch def}forall } if } if
        x1 width ge { x1 y1 x2 y2 width 0 width height .intersect
			{ {y1 x1}{exch def}forall } if } if
        x2 width ge { x1 y1 x2 y2 width 0 width height .intersect
			{ {y2 x2}{exch def}forall } if } if
        y1 width ge { x1 y1 x2 y2 0 height width height .intersect
			{ {y1 x1}{exch def}forall } if } if
        y2 width ge { x1 y1 x2 y2 0 height width height .intersect
			{ {y2 x2}{exch def}forall } if } if
        /x x1 def
        /y y1 def
        x2 x1 sub  dup abs /dx exch def
            .sign /s1 exch def
        y2 y1 sub  dup abs /dy exch def
            .sign /s2 exch def
        /interchange dy dx gt def
        interchange { /dx dy /dy dx def def } if
        /e 2 dy mul dx sub def
        1 1 dx { pop
            r g b x y currentdict PutPix
            {
                e 0 ge not {exit} if
                interchange {
                    /x x s1 add def
                }{
                    /y y s2 add def
                } ifelse
                /e e 2 dx mul sub def
            } loop
            interchange {
                /y y s2 add def
            }{
                /x x s1 add def
            } ifelse
            /e e 2 dy mul add def
        } for
    end } bind

    %  -----|
    %  |    |
    %  |    |
    %  |-----
    /DrawRect { % r g b x y w h IMAGE  .  -
    begin {h w y x b g r}{exch def}forall
        0 1 h 1 sub {
            x 2 copy % h x h x
            exch y add r g b 5 3 roll currentdict PutPix
            w add
            exch y add 1 add r g b 5 3 roll currentdict PutPix
        } for
        1 1 w {
            x add y 2 copy % x+w y x+w y
            r g b 5 3 roll currentdict PutPix
            h add exch 1 sub exch
            r g b 5 3 roll currentdict PutPix
        } for
    end } bind

    /FillRect { % r g b x y w h IMAGE  .  -
    begin {h w y x b g r}{exch def}forall
        %r g b 0 1 h { y add  % r g b y
        %    0 1 w { x add  % r g b y x
        %        5 copy exch % r g b y x r g b x y
        %        currentdict  % r g b y x r g b x y IMAGE
        %        PutPix  % r g b y x
        %        pop  % r g b y
        %    } for
        %    pop % r g b
        %} for
        %pop pop pop % -
		w 0 lt { /w w abs def /x x w sub def } if
		h 0 lt { /h h abs def /y y h sub def } if

		/h h y add def
		/w w x add def

        {
            /USEDRAWLINE where { pop
                USEDRAWLINE {
                    y 1 h {
                        r g b 4 3 roll
                        x exch w 1 index
                        currentdict DrawLine
                    } for
                    exit
                } if
            } if

            r g b
            y 1 h { % r g b y
                x 1 w { % r g b y x
                    5 copy exch % r g b y x r g b x y
                    currentdict PutPix % r g b y x
                    pop % r g b y
                } for
                pop % r g b
            } for
            pop pop pop

        exit } loop

    end } bind


    /.maxmin { % x y
        2 copy
        dup maxy gt { /maxy exch def }{ pop } ifelse
        dup maxx gt { /maxx exch def }{ pop } ifelse
        dup miny lt { /miny exch def }{ pop } ifelse
        dup minx lt { /minx exch def }{ pop } ifelse
    } bind

    % x1 y1 x2 y2 x3 y3 x4 y4  .  x5 y5 true
    %                             false
    % inspired by the code at http: / / alienryderflex.com/intersect/
    /.intersect {
		DICT
		%8 dict
		begin
        {Dy Dx Cy Cx By Bx Ay Ax}{exch def}forall

        %[ Ax Ay Bx By Cx Cy Dx Dy ]{=only( )=only} forall

        { %stopped
            % reject degenerate line
            Ax Bx eq Ay By eq and
            Cx Dx eq Cy Dy eq and or {stop} if

            % reject coinciding endpoints
            Ax Cx eq Ay Cy eq and
            Bx Cx eq By Cy eq and or
            Ax Dx eq Ay Dy eq and or
            Bx Dx eq By Dy eq and or {stop} if

            % translate by -Ax,-Ay
            /Bx Bx Ax sub def /By By Ay sub def
            /Cx Cx Ax sub def /Cy Cy Ay sub def
            /Dx Dx Ax sub def /Dy Dy Ay sub def

            % length of AB
            /distAB Bx Bx mul By By mul add sqrt def

            % rotate AB to x-axis
            /theCos Bx distAB div def
            /theSin By distAB div def
            /newX Cx theCos mul Cy theSin mul add def
            /Cy   Cy theCos mul Cx theSin mul sub def /Cx newX def
            /newX Dx theCos mul Dy theSin mul add def
            /Dy   Dy theCos mul Dx theSin mul sub def /Dx newX def

            % no intersection
            Cy 0 lt Dy 0 lt and Cy 0 ge Dy 0 ge and or {stop} if

            /ABpos Dx Cx Dx sub Dy mul Dy Cy sub div add def
            ABpos 0 lt
            ABpos distAB gt or {stop} if % intersection not on segment

            Ax ABpos theCos mul add
            Ay ABpos theSin mul add
        } stopped not

        %dup { 3 copy =only( )=only exch =only( )=only =only } if ()=

    end }
	dup 0 16 dict put
	bind

    /FillPoly { % r g b polygon IMAGE  .  -
    begin {poly b g r}{exch def}forall

        /DEBUGFILL where { pop
            (\nFillPoly)=
            r =only( )=only g =only( )=only b =only( )=only poly ==
        } if
        hook

        /minx 16#7ffffff def
        /miny minx def
        /maxx minx neg def
        /maxy maxx def
        poly {
            dup type /arraytype eq {
                dup length 2 eq {
                    aload pop .maxmin
                }{
                    pop
                } ifelse
            }{
                pop
            } ifelse
        } forall

        /x_max width .5 add def

        /DEBUGFILL where { pop
            (FillPoly:<intersect polygon edges with scanlines>)=
        } if
        /P poly poly length 1 sub get def
        [
        poly {
            /Q exch def
            /DEBUGFILL where { pop
                (P=)=only P ==
                (Q=)=only Q ==
            } if
            x_max miny floor cvi .5 add % [ x_max miny+.5
            1                           % [ x_max miny+.5 1
            maxy ceiling cvi .5 sub     % [ x_max miny+.5 1 maxy-.5
            {                           % [ ... x_max y
                1 index exch            % [ ... x_max x_max y
                -.5 1 index               % [ ... x_max x_max y -.5 y
                4 2 roll
                P aload pop Q aload pop % [ ... x_max  x_max y  -.5 y  Px Py  Qx Qy
                .intersect {
                    2 array astore exch % [ ... [x y] x_max
                } if
            } for
            pop
            /P Q def
        } forall
        ]        % [list-of-x/y-intersections
        /DEBUGFILL where { pop
            dup ==()=
        } if

        /DEBUGFILL where { pop
            (FillPoly:<sort scanline intersection list>)=
        } if
        {
        dup { % comparitor  % [x1 y1] [x2 y2] . bool
            1 index 1 get
            1 index 1 get
            eq {            % y1 == y2
                exch 0 get
                exch 0 get
                lt             % (x1 < x2)
            }{              % y1 != y2
                exch 1 get
                exch 1 get
                lt             % (y1 < y2)
            } ifelse
        } qsort   % [sorted-list-of-intersections]
        } pop
        dup .yxsort
        /DEBUGFILL where { pop
            dup ==()=
        } if

        %(%lineedit)(r)file pop %pause

        /DEBUGFILL where { pop
            (FillPoly:<set pixels on each scanline>)=
        } if
        aload length 2 idiv { % repeat
            exch aload pop
            3 2 roll aload pop

            {
                /USEDRAWLINE where { pop
                    USEDRAWLINE {
                        r g b 7 3 roll
                        currentdict DrawLine
                        exit
                    } if
                } if

                pop                        % xa ya xb
                3 2 roll                   % ya xb xa
                exch 1 exch                % ya xa 1 xb
                dup width ge { pop width 1 sub } if
                { % for                    % ya x
                    r g b 4 3 roll               % ya r g b x
                    2 index                % ya r g b x ya 
                    currentdict PutPix
                } for
                pop
            exit } loop

        } repeat

    end } bind %FillPoly

    /.printppm { % dump PGM format to stdout
        (P3\n)=only
        dup 0 get length =only %w
        ( )=only
        dup length =only %h
        (\n)=only
        (255\n)=only %max
        {
            {
                dup -16 bitshift =only( )=only
                dup -8 bitshift 16#ff and =only( )=only
                dup 16#ff and =only( )=only
            }forall
            (\n)=only
        }forall %data
        (\n)=only
    } bind

    /.writeppm { % img (filename)
        2 dict begin
        {/f /a}{exch def}forall
        f (P3\n) writestring
        f a 0 get length =string cvs writestring
        f ( ) writestring
        f a length =string cvs writestring
        f (\n255\n) writestring
        a {
            {
                dup -16 bitshift
                =string cvs dup length exch
                    f exch writestring
                    neg 4 add { f ( ) writestring } repeat
                dup -8 bitshift 16#ff and
                =string cvs dup length exch
                    f exch writestring
                    neg 4 add { f ( ) writestring } repeat
                dup 16#ff and
                =string cvs dup length exch
                    f exch writestring
                    neg 4 add { f ( ) writestring } repeat
            } forall
            f (\n) writestring
        } forall
        f (%stdout)(w) file ne {
            f closefile
        } if
        end
    } bind

    /Emit {
    begin
        /OutputFileName where { pop
            ImgData
            OutputFileName (w) file
            .writeppm
        }{
            ImgData
            (%stdout) (w) file
            .writeppm
        } ifelse
    end } bind
>> def

/TESTGRAPHICS where {pop
    (TESTGRAPHICS ppmimage)=
    /dev 40 20 newPPMIMAGEdevice def
    .5 .5 .5 1 1 38 17 dev dup /DrawLine get exec
    .5 .5 .5 9 14 3 3 dev dup /FillRect get exec
    dev dup /Emit get exec
    pstack()=

} if

(eof ppmimage.ps\n)print
